home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _d4e16c872f1eca669ec4ee480c753b7e < prev    next >
Encoding:
Text File  |  2002-05-30  |  11.0 KB  |  364 lines
  1. #
  2. # The help widget that provides both "balloon" and "status bar"
  3. # types of help messages.
  4.  
  5. package Tk::Balloon;
  6.  
  7. use vars qw($VERSION);
  8. $VERSION = '3.037'; # $Id: //depot/Tk8/Tixish/Balloon.pm#37 $
  9.  
  10. use Tk qw(Ev Exists);
  11. use Carp;
  12. require Tk::Toplevel;
  13.  
  14. Tk::Widget->Construct('Balloon');
  15. use base qw(Tk::Toplevel);
  16.  
  17. use UNIVERSAL;
  18.  
  19. use strict;
  20.  
  21. my @balloons;
  22. my $button_up = 0;
  23.  
  24. sub ClassInit {
  25.     my ($class, $mw) = @_;
  26.     $mw->bind('all', '<Motion>', ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
  27.     $mw->bind('all', '<Leave>',  ['Tk::Balloon::Motion', Ev('X'), Ev('Y'), Ev('s')]);
  28.     $mw->bind('all', '<Button>', 'Tk::Balloon::ButtonDown');
  29.     $mw->bind('all', '<ButtonRelease>', 'Tk::Balloon::ButtonUp');
  30.     return $class;
  31. }
  32.  
  33. sub Populate {
  34.     my ($w, $args) = @_;
  35.  
  36.     $w->SUPER::Populate($args);
  37.  
  38.     $w->overrideredirect(1);
  39.     $w->withdraw;
  40.     # Only the container frame's background should be black... makes it
  41.     # look better.
  42.     $w->configure(-background => 'black');
  43.     my $a = $w->Frame;
  44.     my $m = $w->Frame;
  45.     $a->configure(-bd => 0);
  46.     my $al = $a->Label(-bd => 0,
  47.                -relief => 'flat',
  48.                -bitmap => '@' . Tk->findINC('balArrow.xbm'));
  49.     $al->pack(-side => 'left', -padx => 1, -pady => 1, -anchor => 'nw');
  50.     $m->configure(-bd => 0);
  51.     my $ml = $m->Label(-bd => 0,
  52.                -padx => 0,
  53.                -pady => 0,
  54.                -text => $args->{-message});
  55.     $w->Advertise('message' => $ml);
  56.     $ml->pack(-side => 'left',
  57.           -anchor => 'w',
  58.           -expand => 1,
  59.           -fill => 'both',
  60.           -padx => 10,
  61.           -pady => 3);
  62.     $a->pack(-fill => 'both', -side => 'left');
  63.     $m->pack(-fill => 'both', -side => 'left');
  64.  
  65.     # append to global list of balloons
  66.     push(@balloons, $w);
  67.     $w->{'popped'} = 0;
  68.     $w->{'buttonDown'} = 0;
  69.     $w->{'menu_index'} = 'none';
  70.     $w->{'menu_index_over'} = 'none';
  71.     $w->{'canvas_tag'} = '';
  72.     $w->{'canvas_tag_over'} = '';
  73.     $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0],
  74.             -initwait => ['PASSIVE', 'initWait', 'InitWait', 350],
  75.             -state => ['PASSIVE', 'state', 'State', 'both'],
  76.             -statusbar => ['PASSIVE', 'statusBar', 'StatusBar', undef],
  77.             -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''],
  78.             -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''],
  79.             -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'],
  80.             -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef],
  81.             -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef],
  82.             -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef],
  83.             -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'],
  84.             -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'],
  85.             -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1]
  86.            );
  87. }
  88.  
  89. # attach a client to the balloon
  90. sub attach {
  91.     my ($w, $client, %args) = @_;
  92.     foreach my $key (grep(/command$/,keys %args))
  93.      {
  94.       $args{$key} = Tk::Callback->new($args{$key});
  95.      }
  96.     my $msg = delete $args{-msg};
  97.     $args{-balloonmsg} = $msg unless exists $args{-balloonmsg};
  98.     $args{-statusmsg}  = $msg unless exists $args{-statusmsg};
  99.     $w->{'clients'}{$client} = \%args;
  100.     $client->OnDestroy([$w, 'detach', $client]);
  101. }
  102.  
  103. # detach a client from the balloon.
  104. sub detach {
  105.     my ($w, $client) = @_;
  106.     if (Exists($w))
  107.      {
  108.       $w->Deactivate if ($client->IS($w->{'client'}));
  109.      }
  110.     delete $w->{'clients'}{$client};
  111. }
  112.  
  113. sub GetOption
  114. {
  115.  my ($w,$opt,$client) = @_;
  116.  $client = $w->{'client'} unless defined $client;
  117.  if (defined $client)
  118.   {
  119.    my $info = $w->{'clients'}{$client};
  120.    return $info->{$opt} if exists $info->{$opt};
  121.   }
  122.  return $w->cget($opt);
  123. }
  124.  
  125. sub Motion {
  126.     my ($ewin, $x, $y, $s) = @_;
  127.  
  128.     # Don't do anything if a button is down or a grab is active
  129.     # 0x1f00 is (Button1Mask | .. | Button5Mask)
  130.     return if not defined $ewin or ((($s & 0x1f00) or $ewin->grabCurrent()) and not $ewin->isa('Tk::Menu'));
  131.  
  132.     # Find which window we are over
  133.     my $over = $ewin->Containing($x, $y);
  134.  
  135.     foreach my $w (@balloons) {
  136.     # if cursor has moved over the balloon -- ignore
  137.     next if defined $over and $over->toplevel eq $w;
  138.  
  139.     # find the client window that matches
  140.     my $client = $over;
  141.     while (defined $client) {
  142.         last if (exists $w->{'clients'}{$client});
  143.         $client = $client->Parent;
  144.     }
  145.     if (defined $client) {
  146.         # popping up disabled -- ignore
  147.         my $state = $w->GetOption(-state => $client);
  148.         next if $state eq 'none';
  149.         # Check if a button was recently released:
  150.         my $deactivate = 0;
  151.         if ($button_up) {
  152.           $deactivate = 1;
  153.           $button_up = 0;
  154.         }
  155.         # Deactivate it if the motioncommand says to:
  156.             my $command = $w->GetOption(-motioncommand => $client);
  157.         $deactivate = $command->Call($client, $x, $y) if defined $command;
  158.             if ($deactivate)
  159.              {
  160.               $w->Deactivate;
  161.              }
  162.             else
  163.              {
  164.               # warn "deact: $client $w->{'client'}";
  165.               $w->Deactivate unless $client->IS($w->{'client'});
  166.               my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg');
  167.               if (defined($msg))
  168.                {
  169.                 my $delay = delete $w->{'delay'};
  170.                 $delay->cancel if defined $delay;
  171.                 my $initwait = $w->GetOption(-initwait => $client);
  172.                 $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);});
  173.                 $w->{'client'} = $client;
  174.                }
  175.              }
  176.     } else {
  177.         # cursor is at a position covered by a non client
  178.         # pop down the balloon if it is up or scheduled.
  179.         $w->Deactivate;
  180.     }
  181.     }
  182. }
  183.  
  184. sub ButtonDown {
  185.     my ($ewin) = @_;
  186.  
  187.     foreach my $w (@balloons) {
  188.     $w->Deactivate;
  189.     }
  190. }
  191.  
  192. sub ButtonUp {
  193.     $button_up = 1;
  194. }
  195.  
  196. # switch the balloon to a new client
  197. sub SwitchToClient {
  198.     my ($w, $client) = @_;
  199.     return unless Exists($w);
  200.     return unless Exists($client);
  201.     return unless $client->IS($w->{'client'});
  202.     return if $w->grabCurrent and not $client->isa('Tk::Menu');
  203.     my $command = $w->GetOption(-postcommand => $client);
  204.     if (defined $command) {
  205.     # Execute the user's command and return if it returns false:
  206.     my $pos = $command->Call($client);
  207.     return if not $pos;
  208.     if ($pos =~ /^(\d+),(\d+)$/) {
  209.         # Save the returned position so the Popup method can use it:
  210.         $w->{'clients'}{$client}{'postposition'} = [$1, $2];
  211.     }
  212.     }
  213.     my $state = $w->GetOption(-state => $client);
  214.     $w->Popup if ($state =~ /both|balloon/);
  215.     $w->SetStatus if ($state =~ /both|status/);
  216.     $w->{'popped'} = 1;
  217.     $w->{'delay'}  = $w->repeat(200, ['Verify', $w, $client]);
  218. }
  219.  
  220. sub Subclient
  221. {
  222.  my ($w,$data) = @_;
  223.  if (defined($w->{'subclient'}) && (!defined($data) || $w->{'subclient'} ne $data))
  224.   {
  225.    $w->Deactivate;
  226.   }
  227.  $w->{'subclient'} = $data;
  228. }
  229.  
  230. sub Verify {
  231.     my $w      = shift;
  232.     my $client = shift;
  233.     my ($X,$Y) = (@_) ? @_ : ($w->pointerxy);
  234.     my $over = $w->Containing($X,$Y);
  235.     return if not defined $over or ($over->toplevel eq $w);
  236.     my $deactivate = # DELETE? or move it to the isa-Menu section?:
  237.                  # ($over ne $client) or
  238.                  not $client->IS($w->{'client'})
  239.                      or (!$client->isa('Tk::Menu') && $w->grabCurrent);
  240.     if ($deactivate)
  241.      {
  242.       $w->Deactivate;
  243.      }
  244.     else
  245.      {
  246.       $client->BalloonInfo($w,$X,$Y,'-statusmsg','-balloonmsg');
  247.      }
  248. }
  249.  
  250. sub Deactivate {
  251.     my ($w) = @_;
  252.     my $delay = delete $w->{'delay'};
  253.     $delay->cancel if defined $delay;
  254.     if ($w->{'popped'}) {
  255.     my $client = $w->{'client'};
  256.     my $command = $w->GetOption(-cancelcommand => $client);
  257.     if (defined $command) {
  258.         # Execute the user's command and return if it returns false:
  259.         return if not $command->Call($client);
  260.     }
  261.     $w->withdraw;
  262.     $w->ClearStatus;
  263.     $w->{'popped'} = 0;
  264.     $w->{'menu_index'} = 'none';
  265.     $w->{'canvas_tag'} = '';
  266.     }
  267.     $w->{'client'} = undef;
  268.     $w->{'subclient'} = undef;
  269. }
  270.  
  271. sub Popup {
  272.     my ($w) = @_;
  273.     if ($w->cget(-installcolormap)) {
  274.     $w->colormapwindows($w->winfo('toplevel'))
  275.     }
  276.     my $client = $w->{'client'};
  277.     return if not defined $client or not exists $w->{'clients'}{$client};
  278.     my $msg = $client->BalloonInfo($w, $w->pointerxy,'-balloonmsg');
  279.     # Dereference it if it looks like a scalar reference:
  280.     $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  281.  
  282.     $w->Subwidget('message')->configure(-text => $msg);
  283.     $w->idletasks;
  284.  
  285.     return unless Exists($w);
  286.     return unless Exists($client);
  287.     return if $msg eq '';  # Don't popup empty balloons.
  288.  
  289.     my ($x, $y);
  290.     my $pos = $w->GetOption(-balloonposition => $client);
  291.     my $postpos = delete $w->{'clients'}{$client}{'postposition'};
  292.     if (defined $postpos) {
  293.     # The postcommand must have returned a position for the balloon - I will use that:
  294.     ($x, $y) = @{$postpos};
  295.     } elsif ($pos eq 'mouse') {
  296.     $x = int($client->pointerx + 10);
  297.     $y = int($client->pointery + 10);
  298.     } elsif ($pos eq 'widget') {
  299.     $x = int($client->rootx + $client->width/2);
  300.     $y = int($client->rooty + int ($client->height/1.3));
  301.     } else {
  302.     croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'.";
  303.     }
  304.  
  305.     $w->idletasks;
  306.     my($width, $height) = ($w->reqwidth, $w->reqheight);
  307.     my $xx = ($x + $width > $w->screenwidth
  308.           ? $w->screenwidth - $width
  309.           : $x);
  310.     my $yy = ($y + $height > $w->screenheight
  311.           ? $w->screenheight - $height
  312.           : $y);
  313.  
  314.     $w->geometry("+$xx+$yy");
  315.     #$w->MoveToplevelWindow($x,$y);
  316.     $w->deiconify();
  317.     $w->raise;
  318.     #$w->update;  # This can cause confusion by processing more Motion events before this one has finished.
  319. }
  320.  
  321. sub SetStatus {
  322.     my ($w) = @_;
  323.     my $client = $w->{'client'};
  324.     my $s = $w->GetOption(-statusbar => $client);
  325.     if (defined $s and $s->winfo('exists')) {
  326.     my $vref = $s->cget(-textvariable);
  327.     return if not defined $client or not exists $w->{'clients'}{$client};
  328.     my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg');
  329.     # Dereference it if it looks like a scalar reference:
  330.     $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR');
  331.     if (not defined $vref) {
  332.         eval { $s->configure(-text => $msg); };
  333.     } else {
  334.         $$vref = $msg;
  335.     }
  336.     }
  337. }
  338.  
  339. sub ClearStatus {
  340.     my ($w) = @_;
  341.     my $client = $w->{'client'};
  342.     my $s = $w->GetOption(-statusbar => $client);
  343.     if (defined $s and $s->winfo('exists')) {
  344.     my $vref = $s->cget(-textvariable);
  345.     if (defined $vref) {
  346.         $$vref = '';
  347.     } else {
  348.         eval { $s->configure(-text => ''); }
  349.     }
  350.     }
  351. }
  352.  
  353. sub destroy {
  354.     my ($w) = @_;
  355.     @balloons = grep($w != $_, @balloons);
  356.     #$w->SUPER::destroy;
  357.     # Above doesn't seem to work but at least I have removed it from the
  358.     # list of balloons and maybe undef'ing the object will get rid of it.
  359.     undef $w;
  360. }
  361.  
  362. 1;
  363.  
  364.